home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / MACROS.S < prev    next >
Encoding:
Text File  |  1993-11-08  |  21.7 KB  |  705 lines
  1. ; MACROS.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Standard Macro Definitions                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 23 May 86:    Treat (define var form1 ...) illegal--when "var" is a    *
  18. ;*        symbol,    there can be at most 1 form in the body.(rb)    *
  19. ;* - 27 Jan 87:    Included new quasiquote expand.    (tc)            *
  20. ;* - 10 Feb 87:    Changed unfold-define so that MIT style define is not    *
  21. ;*        expanded into named-lambda unless pcs-integrate-define    *
  22. ;*        is #T. This is required for the R^3 Report. (tc)    *
  23. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  24. ;*                                    *
  25. ;*                    ``In nomine omnipotentii dei''    *
  26. ;************************************************************************
  27.  
  28. ; runtime version of CREATE-SCHEME-MACRO is in TOPLEVEL.S
  29. ; (because this file isn't used when making runtime system)
  30.  
  31. (define create-scheme-macro                ; CREATE-SCHEME-MACRO
  32.   (lambda (name handler)
  33.     (if (null? handler)
  34.     (remprop name 'PCS*MACRO)
  35.     (putprop name handler 'PCS*MACRO))
  36.     name))
  37.  
  38. (define %expand-syntax-form                             ; %EXPAND-SYNTAX-FORM
  39.   (lambda (form pat exp)
  40.      (letrec
  41.        ((compare
  42.           (lambda (f p)
  43.               (cond ((atom? p)
  44.                      (cond ((symbol? p)
  45.                             (list (cons p f)))
  46.                            ((and (null? p) (null? f))
  47.                             '())
  48.                            (else (oops))))
  49.                     ((atom? f)
  50.                      (oops))
  51.                     ((atom? (car p))
  52.                      (cons (cons (car p)(car f))
  53.                            (compare (cdr f)(cdr p))))
  54.                     (else
  55.                      (append! (compare (car f)(car p))
  56.                               (compare (cdr f)(cdr p)))))))
  57.         (substitute
  58.           (lambda (id-list exp)
  59.               (cond ((pair? exp)
  60.                      (cons (substitute id-list (car exp))
  61.                            (substitute id-list (cdr exp))))
  62.                     ((symbol? exp)
  63.                      (let ((x (assq exp id-list)))
  64.                        (if (null? x)
  65.                            exp
  66.                            (cdr x))))
  67.                     (else exp))))
  68.         (oops
  69.           (lambda ()
  70.               (syntax-error "Invalid special form" form))))
  71.  
  72.      (substitute (compare (cdr form) pat) exp))))
  73.  
  74. (letrec
  75.  ((csm
  76.    (lambda (name handler)
  77.      (putprop name handler 'PCS*MACRO)))
  78.  
  79.   (make-begin
  80.     (lambda (x)
  81.       (if (null? (cdr x))
  82.       (car x)
  83.       (cons 'BEGIN x))))
  84.  
  85.   (unfold-define
  86.    (lambda (form)
  87.      (pcs-chk-length>= form form 2)
  88.      (let ((op     (car form))       ; DEFINE or DEFINE-INTEGRABLE
  89.        (spec (cadr form))       ; ID or (spec . bvl)
  90.        (body (cddr form)))       ; rest after removing first 2 elts
  91.        (cond ((null? body)
  92.           (unfold-define `(,op ,spec '#!UNASSIGNED)))
  93.          ((pair? spec)
  94.           (let ((name (car spec))
  95.             (bvl  (cdr spec)))
  96.         (pcs-chk-bvl form bvl #T)
  97.         (unfold-define
  98.             (if (pair? name)
  99.             `(,op ,name (LAMBDA ,bvl . ,body))
  100.             (if pcs-integrate-define
  101.                 `(,op ,name (NAMED-LAMBDA ,spec . ,body))
  102.                 `(,op ,name (LAMBDA ,bvl . ,body))) ))))
  103.          (else
  104.           (pcs-chk-length= form form 3)
  105.           form)))))
  106.  
  107.   ;; EXPAND-QUASIQUOTE is adapted from an algorithm placed in
  108.   ;; the public domain (the RRRS-Authors mailing list) on
  109.   ;; 22-Dec-86 by Jonathan Rees of MIT.
  110.  
  111.   (expand-quasiquote
  112.     (lambda (x level)
  113.       (descend-quasiquote x level finalize-quasiquote)))
  114.  
  115.   (finalize-quasiquote
  116.     (lambda (mode arg)
  117.       (cond ((eq? mode 'QUOTE)  `',arg)
  118.         ((eq? mode 'UNQUOTE) arg)
  119.         ((eq? mode 'UNQUOTE-SPLICING)
  120.          (syntax-error ",@ in illegal context" arg))
  121.         ((eq? mode 'UNQUOTE-SPLICING!)
  122.          (syntax-error ",. in illegal context" arg))
  123.         (else `(,mode ,@arg)))))
  124.  
  125.   (descend-quasiquote
  126.       (lambda (x level return)
  127.         (cond ((vector? x)
  128.            (descend-quasiquote-vector x level return))
  129.           ((not (pair? x))
  130.            (return 'QUOTE x))
  131.           ((eq? (car x) 'QUASIQUOTE)
  132.            (descend-quasiquote-pair x (+ level 1) return))
  133.           ((memq (car x) '(UNQUOTE UNQUOTE-SPLICING UNQUOTE-SPLICING!))
  134.            (if (zero? level)
  135.                (return (car x) (cadr x))
  136.                (descend-quasiquote-pair x (- level 1) return)))
  137.           (else
  138.            (descend-quasiquote-pair x level return)))))
  139.  
  140.   (descend-quasiquote-pair
  141.       (lambda (x level return)
  142.         (descend-quasiquote (car x) level        ; process (car x)
  143.           (lambda (car-mode car-arg)
  144.         (descend-quasiquote (cdr x) level    ; process (cdr x)
  145.           (lambda (cdr-mode cdr-arg)
  146.             (cond ((and (eq? car-mode 'QUOTE)
  147.                 (eq? cdr-mode 'QUOTE))
  148.                (return 'QUOTE x))
  149.               ((eq? car-mode 'UNQUOTE-SPLICING)     ; (,@foo ...)
  150.                (if (and (eq? cdr-mode 'QUOTE)
  151.                     (null? cdr-arg))
  152.                    (return 'UNQUOTE car-arg)
  153.                    (return 'APPEND
  154.                        (list car-arg
  155.                          (finalize-quasiquote
  156.                          cdr-mode cdr-arg)))))
  157.               ((eq? car-mode 'UNQUOTE-SPLICING!)    ; (,.foo ...)
  158.                (if (and (eq? cdr-mode 'QUOTE)
  159.                     (null? cdr-arg))
  160.                    (return 'UNQUOTE car-arg)
  161.                    (return 'APPEND!
  162.                        (list car-arg
  163.                          (finalize-quasiquote
  164.                          cdr-mode cdr-arg)))))
  165.               (else
  166.                (return 'CONS
  167.                    (list (finalize-quasiquote car-mode car-arg)
  168.                      (finalize-quasiquote cdr-mode cdr-arg)
  169.                      )))
  170.               )))))))
  171.  
  172.   (descend-quasiquote-vector
  173.       (lambda (x level return)
  174.         (descend-quasiquote (vector->list x) level
  175.           (lambda (mode arg)
  176.         (if (eq? mode 'QUOTE)
  177.             (return 'QUOTE x)
  178.             (return 'LIST->VECTOR
  179.                 (list (finalize-quasiquote mode arg))))))))
  180.  )
  181.  
  182. ;---- begin LETREC body ----
  183.  
  184. (csm 'access                        ; ACCESS
  185.   (lambda (form)
  186.     (letrec ((help
  187.           (lambda (form L)
  188.         (let ((sym (car L))
  189.               (env (if (null? (cddr L))   ; (access sym env)
  190.                    (cadr L)
  191.                    (list 'CDR (help form (cdr L))))))
  192.           (pcs-chk-id form sym)
  193.           `(%ENV-LU (QUOTE ,sym) ,env)))))
  194.        (pcs-chk-length>= form form 2)
  195.        (let ((id (cadr form)))
  196.      (pcs-chk-id form id)
  197.      (if (null? (cddr form))
  198.          id                   ; (access id)
  199.          (list '%CDR
  200.            (help form (cdr form))))))))
  201.  
  202. (csm 'alias                                             ; ALIAS
  203.   (lambda (form)
  204.     (pcs-chk-length= form form 3)
  205.     (let ((id  (cadr form))
  206.       (exp (caddr form)))
  207.       (pcs-chk-id form id)
  208.       `(CREATE-SCHEME-MACRO
  209.      ',id
  210.      (CONS 'ALIAS ',exp)))))
  211.  
  212. (csm 'and                                               ; AND
  213.   (lambda (form)
  214.     (cond ((atom? form)    (lambda args
  215.               (if (null? args)
  216.                   #T
  217.                   (do ((args args (cdr args)))
  218.                   ((or (not (car args)) (null? (cdr args))) (car args))))))
  219.       (else (pcs-chk-length>= form form 1)
  220.         (cond ((null? (cdr form)) #T)
  221.               ((null? (cddr form)) (cadr form))
  222.               (else `(IF ,(cadr form)
  223.                  (AND . ,(cddr form))
  224.                  #F)))))))
  225.  
  226. (csm 'apply-if                                          ; APPLY-IF
  227.   (lambda (form)
  228.     (pcs-chk-length>= form form 3)
  229.     (let ((temp (gensym))
  230.       (predicate (cadr form))
  231.       (true-proc (caddr form))
  232.       (false-exp (cdddr form)))
  233.       `(LET ((,temp ,predicate))
  234.      (IF ,temp (,true-proc ,temp) ,@false-exp)))))
  235.  
  236. (csm 'assert                                            ; ASSERT
  237.   (lambda (form)
  238.     (pcs-chk-length>= form form 2)
  239.     (let ((pred (cadr form))
  240.       (msg    (cons 'LIST (cddr form)))
  241.       (env    (if pcs-debug-mode '(THE-ENVIRONMENT) '())))
  242.       `(IF ,pred
  243.        '()
  244.        (BEGIN (ASSERT-PROCEDURE ,msg ,env)
  245.           '())))))      ; make call non-tail-recursive
  246.  
  247. (csm 'begin0                                            ; BEGIN0
  248.   (lambda (form)
  249.     (pcs-chk-length>= form form 2)
  250.     (let ((temp (gensym))
  251.       (first (cadr form))
  252.       (rest (cddr form)))
  253.       `(LET ((,temp ,first))
  254.      (BEGIN ,@rest ,temp)))))
  255.  
  256. (csm 'bkpt                                              ; BKPT
  257.   (lambda (form)
  258.     (pcs-chk-length= form form 3)
  259.     `(BEGIN (BREAKPOINT-PROCEDURE ,(cadr form)
  260.                   ,(caddr form)
  261.                   (THE-ENVIRONMENT))
  262.         '())))      ; make call non-tail-recursive
  263.  
  264. (csm 'case                                              ; CASE
  265.   (lambda (form)
  266.     (pcs-chk-length>= form form 2)
  267.     (let ((temp (gensym))
  268.       (tag (cadr form))
  269.       (pairs (cddr form)))
  270.       `(LET ((,temp ,tag))
  271.      ,(let loop ((p pairs))
  272.         (if (null? p)
  273.         p
  274.         (let ((clause (car p)))
  275.           (pcs-chk-length>= clause clause 2)
  276.           (let ((match  (if (and (pair? (car clause))
  277.                      (atom? (caar clause))
  278.                      (null? (cdar clause)))
  279.                     (caar clause)
  280.                     (car clause)))
  281.             (result (make-begin (cdr clause))))
  282.             (if (and (null? (cdr p))
  283.                  (eq? match 'ELSE))
  284.             result
  285.             `(IF (,(if (pair? match) 'MEMV 'EQV?) ,temp ',match)
  286.                  ,result
  287.                  ,(loop (cdr p))))))))))))
  288.  
  289. (csm 'cond                                              ; COND
  290.   (lambda (form)
  291.     (pcs-chk-length>= form form 1)
  292.     (let ((e (cdr form)))
  293.       (if (null? e)
  294.       e
  295.       (let ((clause (car e)))
  296.         (pcs-chk-length>= form clause 1)
  297.         (if (and (null? (cdr e))
  298.              (eq? (car clause) 'ELSE))
  299.         (if (null? (cdr clause))
  300.             #T
  301.             (make-begin (cdr clause)))     ; exp
  302.         (let ((test (car clause))     ; a
  303.               (then (cdr clause))     ; b
  304.               (tail (cons 'COND (cdr e))))
  305.           (if (null? (cdr e))
  306.               (cond ((null? then) test)
  307.                 ((eq? (car then) '|=>|)
  308.                  (pcs-chk-length= form clause 3)
  309.                  `(APPLY-IF ,test ,(cadr then) #F))
  310.                 (else `(IF ,test ,(make-begin then) #F)))
  311.               (cond ((null? then)
  312.                  `(OR ,test ,tail))
  313.                 ((eq? (car then) '|=>|)
  314.                  (pcs-chk-length= form clause 3)
  315.                  `(APPLY-IF ,test ,(cadr then) ,tail))
  316.                 (else `(IF ,test ,(make-begin then) ,tail)))
  317.           ))))))))
  318.  
  319. (csm 'cons-stream                                       ; CONS-STREAM
  320.   (lambda (form)
  321.     (pcs-chk-length= form form 3)
  322.     `(VECTOR '#!STREAM
  323.          ,(cadr form)
  324.          (%DELAY (LAMBDA () ,(caddr form))))))
  325.  
  326. (csm 'define                                            ; DEFINE
  327.   (lambda (form)
  328.     (unfold-define form)))
  329.  
  330. (csm 'define-integrable                                 ; DEFINE-INTEGRABLE
  331.   (lambda (form)
  332.     (if (cddr form)
  333.     (pcs-chk-length= form form 3))
  334.     (let* ((form (unfold-define form))
  335.        (id    (cadr form))
  336.        (exp (caddr form)))
  337.       (pcs-chk-id form id)
  338.       (if (equal? exp ''#!UNASSIGNED)
  339.       `(BEGIN
  340.          (REMPROP ',id
  341.               'PCS*PRIMOP-HANDLER)
  342.          (QUOTE ,id))
  343.       `(BEGIN
  344.          (PUTPROP ',id
  345.               (CONS 'DEFINE-INTEGRABLE ',exp)
  346.               'PCS*PRIMOP-HANDLER)
  347.          (QUOTE ,id)))
  348.     )))
  349.  
  350. (csm 'define-structure                                  ; DEFINE-STRUCTURE
  351.   (lambda (form)
  352.     (%define-structure form)))
  353.  
  354. (csm 'delay                                             ; DELAY
  355.   (lambda (form)
  356.     (pcs-chk-length= form form 2)
  357.     `(VECTOR '#!DELAYED-OBJECT
  358.          (%DELAY (LAMBDA () ,(cadr form))))))
  359.  
  360. (csm 'do                                                ; DO
  361.   (lambda (form)
  362.     (letrec ((triplify
  363.           (lambda (old new)
  364.         (cond ((null? old) (%reverse! new))
  365.               ((list? old)
  366.                (let* ((x (car old))
  367.                   (y (cond ((atom? x) (list x '() x))
  368.                        ((atom? (cdr x)) (list (car x) '() (car x)))
  369.                        ((atom? (cddr x)) (list (car x) (cadr x) (car x)))
  370.                        ((null? (cdddr x)) x)
  371.                        (else (syntax-error "Invalid DO list item: " x)))))
  372.              (pcs-chk-id x (car y))
  373.              (triplify (cdr old) (cons y new))))
  374.               (else (syntax-error "Invalid DO triples list: " form))))))
  375.       (pcs-chk-length>= form form 3)
  376.       (let* ((triples (triplify (cadr form) '()))
  377.          (vars (map car triples))
  378.          (inits (map cadr triples))
  379.          (steps (map caddr triples))
  380.          (terminate (caddr form))
  381.          (statements (cdddr form))
  382.          (me (gensym)))
  383.     (pcs-chk-length>= form terminate 1)
  384.     (let* ((test (car terminate))
  385.            (body (if (null? statements)
  386.              (cons me steps)
  387.              `(BEGIN ,@statements (,me ,@steps))))
  388.            (loop (if (null? (cdr terminate))
  389.              (let ((temp (gensym)))
  390.                `(LET ((,temp ,test))
  391.                   (IF ,temp ,temp ,body)))
  392.              `(IF ,test
  393.                   ,(make-begin (cdr terminate))
  394.                   ,body))))
  395.       `(LETREC ((,me (LAMBDA ,vars
  396.                ,loop)))
  397.          (,me ,@inits)))))))
  398.  
  399. (csm 'error                                             ; ERROR
  400.   (lambda (form)
  401.     (pcs-chk-length>= form form 2)
  402.     (let ((msg (cadr form))
  403.       (irr (cond ((null? (cddr form))
  404.               '())
  405.              ((null? (cdddr form))
  406.               (caddr form))
  407.              (else
  408.               (cons 'LIST (cddr form)))))
  409.       (env (if pcs-debug-mode '(THE-ENVIRONMENT) '())))
  410.       `(BEGIN (ERROR-PROCEDURE ,msg ,irr ,env)
  411.           '()))))   ; make call non-tail-recursive
  412.  
  413. (csm 'fluid                                             ; FLUID
  414.   (lambda (form)
  415.     (pcs-chk-length= form form 2)
  416.     (pcs-chk-id form (cadr form))
  417.     `(%%GET-FLUID%% (QUOTE ,(cadr form)))))
  418.  
  419. (csm 'fluid-bound?                                      ; FLUID-BOUND?
  420.   (lambda (form)
  421.     (pcs-chk-length= form form 2)
  422.     (pcs-chk-id form (cadr form))
  423.     `(%%FLUID-BOUND?%% (QUOTE ,(cadr form)))))
  424.  
  425. (csm 'fluid-lambda                                      ; FLUID-LAMBDA
  426.   (lambda (form)
  427.     (letrec
  428.      ((add-bindings
  429.        (lambda (bvl fvl body-list)
  430.      (if (null? bvl)
  431.          (cons 'BEGIN body-list)
  432.          (add-bindings (cdr bvl) (cdr fvl)
  433.                `((%%BIND-FLUID%%
  434.                   (QUOTE ,(car fvl))
  435.                   ,(car bvl))
  436.                  . ,body-list))))))
  437.      (pcs-chk-length>= form form 3)
  438.      (pcs-chk-bvl form (cadr form) #F)
  439.      (if (null? (cadr form))
  440.      (cons 'LAMBDA (cdr form))
  441.      (let* ((fvl  (cadr form))
  442.         (bvl  (mapcar (lambda (fv)(gensym '*))
  443.                   fvl))
  444.         (ans  (gensym '*))
  445.         (body (cons 'BEGIN (cddr form))))
  446.        (list 'LAMBDA
  447.          bvl
  448.          (add-bindings
  449.              (%reverse! (%append bvl '())) ; don't destroy lists
  450.              (%reverse! (%append fvl '()))
  451.              `((LET ((,ans ,body))
  452.              (BEGIN
  453.                (%%UNBIND-FLUID%% ',fvl)
  454.                ,ans))))))))))
  455.  
  456. (csm 'fluid-let                                         ; FLUID-LET
  457.   (lambda (form)
  458.     (pcs-chk-length>= form form 3)
  459.     (let ((pairs (cadr form))
  460.       (body (cddr form)))
  461.       (pcs-chk-pairs form pairs)
  462.       `((FLUID-LAMBDA ,(mapcar car pairs)
  463.         (BEGIN . ,body))
  464.     . ,(mapcar cadr pairs)))))
  465.  
  466. (csm 'freeze                                            ; FREEZE
  467.   (lambda (form)
  468.     (pcs-chk-length>= form form 2)
  469.     (let ((body (cdr form)))
  470.       `(LAMBDA () . ,body))))
  471.  
  472. (csm 'inspect                        ; INSPECT
  473.   (lambda (form)
  474.     (pcs-chk-length>= form form 1)
  475.     (let ((env (if (cdr form)
  476.          (begin
  477.            (pcs-chk-length= form form 2)
  478.            (cadr form))
  479.          '(THE-ENVIRONMENT))))
  480.       `(begin
  481.      (%inspect ,env)
  482.      *the-non-printing-object*))))
  483.  
  484. (csm 'let                                               ; LET
  485.   (lambda (form)
  486.     (pcs-chk-length>= form form 3)
  487.     (if (and (symbol? (cadr form))            ; named LET
  488.          (not (null? (cadr form))))
  489.     (begin
  490.       (pcs-chk-length>= form form 4)
  491.       (let ((name (cadr form))
  492.         (pairs (caddr form))
  493.         (body  (cdddr form)))
  494.         (pcs-chk-pairs form pairs)
  495.         `((REC ,name (LAMBDA ,(mapcar car pairs) . ,body))
  496.           . ,(mapcar cadr pairs))))
  497.     (let ((pairs (cadr form))            ; unnamed LET
  498.           (body (cddr form)))
  499.       (pcs-chk-pairs form pairs)
  500.       `((LAMBDA ,(mapcar car pairs)
  501.           . ,body)
  502.         . ,(mapcar cadr pairs))))))
  503.  
  504. (csm 'let*                                              ; LET*
  505.   (lambda (form)
  506.     (pcs-chk-length>= form form 3)
  507.     (let ((pairs (cadr form))
  508.       (body (cddr form)))
  509.       (if (null? pairs)
  510.       `(BEGIN . ,body)
  511.       (begin
  512.         (pcs-chk-pairs form pairs)
  513.         (let ((id (caar pairs))
  514.           (exp (cadar pairs)))
  515.           `((LAMBDA (,id)
  516.           (LET* ,(cdr pairs) . ,body))
  517.         ,exp)))))))
  518.  
  519. (csm 'macro                                             ; MACRO
  520.   (lambda (form)
  521.     (pcs-chk-length= form form 3)
  522.     (let ((id (cadr form))
  523.       (fn (caddr form)))
  524.       (pcs-chk-id form id)
  525.       `(CREATE-SCHEME-MACRO (QUOTE ,id) ,fn))))
  526.  
  527. (csm 'make-environment                                  ; MAKE-ENVIRONMENT
  528.   (lambda (form)
  529.     (pcs-chk-length>= form form 1)
  530.     `(LET ()
  531.        ,@(cdr form)
  532.        (THE-ENVIRONMENT))))
  533.  
  534. (csm 'make-hashed-environment                           ; MAKE-HASHED-ENVIRONMENT
  535.   (lambda (form)
  536.     (pcs-chk-length>= form form 1)
  537.     `(LET ()
  538.        (%make-hashed-environment))))
  539.  
  540. (csm 'named-lambda                                      ; NAMED-LAMBDA
  541.   (lambda (form)
  542.     (pcs-chk-length>= form form 3)
  543.     (let ((bvl+ (cadr form)))
  544.       (pcs-chk-bvl form bvl+ (not (atom? bvl+)))
  545.       (let ((name (car bvl+))
  546.         (bvl  (cdr bvl+))
  547.         (body (cddr form)))
  548.     `(REC ,name (LAMBDA ,bvl . ,body))))))
  549.  
  550. (csm 'or                                                ; OR
  551.   (lambda (form)
  552.     (cond ((atom? form) (lambda args (do ((args args (cdr args)))
  553.                      ((or (null? args) (car args))
  554.                       (if (null? args) #F (car args))))))
  555.       (else (pcs-chk-length>= form form 1)
  556.         (cond ((null? (cdr form)) #F)
  557.               ((null? (cddr form)) (cadr form))
  558.               ((or (atom? (cadr form))
  559.                (eq? (car (cadr form)) 'QUOTE))
  560.                `(IF ,(cadr form) ,(cadr form)
  561.                 (OR . ,(cddr form))))
  562.               (else (let ((temp (gensym)))
  563.                   `(LET ((,temp ,(cadr form)))
  564.                  (IF ,temp ,temp (OR . ,(cddr form)))))))))))
  565.  
  566. (csm 'quasiquote                                        ; QUASIQUOTE
  567.   (lambda (form)
  568.     (pcs-chk-length= form form 2)
  569.     (expand-quasiquote (cadr form) 0)))
  570.  
  571. (csm 'rec                                               ; REC
  572.   (letrec ((nice-bvl?
  573.         (lambda (bvl)
  574.           (cond ((null? bvl) #T)
  575.             ((atom? bvl) #F)
  576.             ((eq? (car bvl) '#!OPTIONAL) #F)
  577.             (else (nice-bvl? (cdr bvl)))))))
  578.      (lambda (form)
  579.        (pcs-chk-length= form form 3)
  580.        (let ((id  (cadr form))
  581.          (exp (caddr form)))
  582.      (pcs-chk-id form id)
  583.      (if (and (not pcs-debug-mode)
  584.           (pair? exp)
  585.           (eq? (car exp) 'LAMBDA)
  586.           (pair? (cdr exp))
  587.           (nice-bvl? (cadr exp)))
  588.          (let ((bvl (cadr exp)))
  589.            `(LETREC ((,id ,exp))
  590.              (LAMBDA ,bvl (,id . ,bvl))))
  591.          `(LETREC ((,id ,exp)) ,id))))))
  592.  
  593. (csm 'sequence                                          ; SEQUENCE
  594.   (lambda (form)
  595.     (pcs-chk-length>= form form 1)
  596.     (cons 'BEGIN (cdr form))))
  597.  
  598. (csm 'set-fluid!                                        ; SET-FLUID!
  599.   (lambda (form)
  600.     (pcs-chk-length= form form 3)
  601.     (pcs-chk-id form (cadr form))
  602.     `(%%SET-FLUID%% (QUOTE ,(cadr form))
  603.             ,(caddr form))))
  604.  
  605. (csm 'set!                                              ; SET!
  606.   (lambda (form)
  607.     (pcs-chk-length= form form 3)
  608.     (let ((spec (cadr form))
  609.       (value (caddr form)))
  610.       (if (pair? spec)
  611.       (let ((op (car spec)))
  612.         (case op
  613.           ((ACCESS)
  614.           (pcs-chk-length>= spec spec 2)
  615.           (let ((temp (gensym))
  616.             (sym (cadr spec))
  617.             (env (cond ((null? (cddr spec)) '(THE-ENVIRONMENT))
  618.                    ((null? (cdddr spec)) (caddr spec))
  619.                    (else `(ACCESS . ,(cddr spec))))))
  620.             (pcs-chk-id spec sym)
  621.  
  622.             `(LET ((,temp ,env))
  623.             (%DEFINE ',sym ,value ,temp)
  624.             '())
  625.  
  626. ;;;            `(LET* ((%00000    ; do this first, since it
  627. ;;;                ,env)  ; may be (THE-ENVIRONMENT)
  628. ;;;                (%00001 ,value)
  629. ;;;                (%00002 (%SET-GLOBAL-ENVIRONMENT %00000)))
  630. ;;;               (%%DEF-GLOBAL%% ',sym %00001)
  631. ;;;               (%SET-GLOBAL-ENVIRONMENT %00002)
  632. ;;;               '())
  633.  
  634.                ))
  635.           ((FLUID)
  636.           (pcs-chk-length= spec spec 2)
  637.           (pcs-chk-id spec (cadr spec))
  638.           `(SET-FLUID! ,(cadr spec) ,value))
  639.           ((VECTOR-REF)
  640.           (pcs-chk-length= spec spec 3)
  641.           `(VECTOR-SET! ,(cadr spec) ,(caddr spec) ,value))
  642.           (else
  643.            (let ((mac (getprop op 'PCS*MACRO)))
  644.          (if (null? mac)
  645.              (let ((g (getprop op 'PCS*PRIMOP-HANDLER)))
  646.                (if (and (pair? g)
  647.                 (eq? (car g) 'DEFINE-INTEGRABLE)
  648.                 (pair? (cdr g))
  649.                 (eq? (cadr g) 'LAMBDA)
  650.                 (pair? (cddr g))
  651.                 (pair? (cdddr g))
  652.                 (null? (cddddr g)))
  653.                (let ((args (caddr g))
  654.                  (body (cadddr g)))
  655.                  `((LAMBDA ,args (SET! ,body ,value))
  656.                    ,@(cdr spec)))
  657.                form))
  658.              `(SET! ,(if (pair? mac)
  659.                  (cons (cdr mac)(cdr spec))  ; alias
  660.                  (mac spec))             ; macro
  661.                 ,value))))))
  662.       form))))
  663.  
  664. (csm 'syntax                                            ; SYNTAX
  665.   (lambda (form)
  666.     (pcs-chk-length= form form 3)
  667.     (let ((pat (cadr form))
  668.       (exp (caddr form)))
  669.       (if (and (pair? pat)(symbol? (car pat)))
  670.       `(CREATE-SCHEME-MACRO
  671.           ',(car pat)       ; macro name
  672.           (LAMBDA (FORM)
  673.         (%EXPAND-SYNTAX-FORM FORM ',(cdr pat) ',exp)))
  674.       (syntax-error "Invalid SYNTAX form: " form)))))
  675.  
  676. (csm 'unassigned?                                       ; UNASSIGNED?
  677.   (lambda (form)
  678.     (pcs-chk-length= form form 2)
  679.     (let ((sym (cadr form)))
  680.       (pcs-chk-id form sym)
  681.       `(EQ? ,sym '#!UNASSIGNED))))
  682.  
  683. (csm 'unbound?                                          ; UNBOUND?
  684.   (lambda (form)
  685.     (pcs-chk-length>= form form 2)
  686.     (let ((sym (cadr form))
  687.       (env (cond ((null? (cddr form))
  688.               (list 'THE-ENVIRONMENT))
  689.              ((null? (cdddr form))
  690.               (caddr form))
  691.              (else
  692.               (cons 'ACCESS (cddr form))))))
  693.       (pcs-chk-id form sym)
  694.       `(NULL? (%ENV-LU (QUOTE ,sym) ,env)))))
  695.  
  696. (csm 'when                                              ; WHEN
  697.   (lambda (form)
  698.     (pcs-chk-length>= form form 3)
  699.     (let ((pred (cadr form))
  700.       (body (cons 'BEGIN (cddr form))))
  701.       `(IF ,pred ,body '()))))
  702.  
  703. '()
  704. ) ;---- end LETREC body ----
  705.